unit SystemExceptionHandling;

interface

implementation

uses
  Windows, SysUtils;

// Inspired by what is described at FPC's forums:
// http://bugs.freepascal.org/view.php?id=12974 [^]
//
// especially in comment 0040683 by Bernd Kreuss

procedure UnwindFloatingPointException; assembler;
{$IFDEF WIN32}
asm
  fnclex
  emms
end;
{$ENDIF WIN32}
{$IFDEF WIN64}
var
  ControlWord: DWORD;
asm
  stmxcsr ControlWord
  and ControlWord, $FFE0
  ldmxcsr ControlWord
end;
{$ENDIF WIN64}

function ExceptionHandler(Info: PEXCEPTION_POINTERS): LongInt; stdcall;

  function GetModuleBaseByAddr(Addr: Pointer): Pointer;
  var
    Tmm: TMemoryBasicInformation;
  begin
    if VirtualQuery(addr, @Tmm, SizeOf(Tmm)) <> SizeOf(Tmm) then
      Result := nil
    else
      Result := Tmm.AllocationBase;
  end;
  
  procedure SetContinueAddress(Addr: Pointer);
  begin
    // clear the windows exception and point it to a place that
    // will raise a pascal exception instead.
    {$IFDEF WIN32}
    Info^.ContextRecord^.Eip :=
    {$ENDIF WIN32}
    {$IFDEF WIN64}
    Info^.ContextRecord^.Rip :=
    {$ENDIF WIN64}
      {$HINTS OFF}
      PtrUInt(Addr);
      {$HINTS ON}
  end;

label
  lblRaiseAccessViolation;
label
  lblRaiseFloatDivideByZero;
label
  lblRaiseFloatInvalidOperation;
label
  lblRaiseFloatOverflow;
label
  lblRaiseFloatUnderflow;
label
  lblRaiseIntDivideByZero;
label
  lblRaiseIntOverflow;

begin
  // did it happen in the same module where this function resides?
  if GetModuleBaseByAddr(Info^.ExceptionRecord^.ExceptionAddress) = GetModuleBaseByAddr(@lblRaiseAccessViolation) then
  begin
    UnwindFloatingPointException;
    // we only care about some exceptions
    case Info^.ExceptionRecord^.ExceptionCode of
      STATUS_ACCESS_VIOLATION:
        SetContinueAddress(@lblRaiseAccessViolation);
      EXCEPTION_FLT_DIVIDE_BY_ZERO:
        SetContinueAddress(@lblRaiseFloatDivideByZero);
      EXCEPTION_FLT_INVALID_OPERATION:
        SetContinueAddress(@lblRaiseFloatInvalidOperation);
      EXCEPTION_FLT_OVERFLOW:
        SetContinueAddress(@lblRaiseFloatOverflow);
      EXCEPTION_FLT_UNDERFLOW:
        SetContinueAddress(@lblRaiseFloatUnderflow);
      EXCEPTION_INT_DIVIDE_BY_ZERO:
        SetContinueAddress(@lblRaiseIntDivideByZero);
      EXCEPTION_INT_OVERFLOW:
        SetContinueAddress(@lblRaiseIntOverflow);
      else
        Exit(EXCEPTION_CONTINUE_SEARCH);
    end;
    
    Exit(EXCEPTION_CONTINUE_EXECUTION);
  end
  else
  begin
    Exit(EXCEPTION_CONTINUE_SEARCH);
  end;

  // the following will never be reached during this function call,
  // instead it will be jumped to and executed *after* this function has
  // returned and windows restarts execution at the new position of eip/rip.
lblRaiseAccessViolation:
  raise EAccessViolation.Create('Access violation');
lblRaiseFloatDivideByZero:
  UnwindFloatingPointException;
  raise EZeroDivide.Create('Floating point divide by zero');
lblRaiseFloatInvalidOperation:
  UnwindFloatingPointException;
  raise EInvalidOp.Create('Invalid operation');
lblRaiseFloatOverflow:
  UnwindFloatingPointException;
  raise EOverflow.Create('Float overflow');
lblRaiseFloatUnderflow:
  UnwindFloatingPointException;
  raise EUnderflow.Create('Float underflow');
lblRaiseIntDivideByZero:
  raise EDivByZero.Create('Integer divide by zero');
lblRaiseIntOverflow:
  raise EIntOverflow.Create('Integer overflow');
end;

function AddVectoredExceptionHandler(FirstHandler: DWORD; VectoredHandler: pointer): pointer; stdcall; external 'kernel32.dll' name 'AddVectoredExceptionHandler';
function RemoveVectoredExceptionHandler(VectoredHandlerHandle: pointer): ULONG; stdcall; external 'kernel32.dll' name 'RemoveVectoredExceptionHandler';

const
  CALL_FIRST = 1;

var
  ExceptionHandle: Pointer;

initialization
  ExceptionHandle := AddVectoredExceptionHandler(CALL_FIRST, @ExceptionHandler);

finalization
  RemoveVectoredExceptionHandler(ExceptionHandle);

end.
